home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / qbcalc.arc / CALC.ASC next >
Text File  |  1987-02-15  |  14KB  |  360 lines
  1.  
  2.         ' TSR (Memory Resident) 4 Function Calculator
  3.         ' by Kauko J. Laurinolli 404-981-9550
  4.         ' Feb. 15, 1987
  5.  
  6.         ' Be my quest, use, modify, improve and mutilate this Freebie code the way you wish
  7.         ' No Guarantee of any kind provided
  8.  
  9.         ' STAYRES and MACH2 Copyrighted by Micro-Help
  10.  
  11.         ' Sample Compiled with Qbasic  V2.01, works also with V1.01 or V2.00
  12.         '        Linked   with MS-Link V3.06
  13.  
  14.         ' bascom calc.asc/o;
  15.         ' link stayres+calc/e+gwcom,,nul,bcom20+mhlib
  16.  
  17.         ' Program uses EMS memory if available
  18.         ' Activate with Alt X
  19.         ' Use H to get help after program is activated with Alt X
  20.  
  21.         ' This program uses couple of great programmers utilities:
  22.         '╔═════════════════════════════════════════════════════════════════════╗
  23.         '║   Stay-Res Program Package to Make Basic Program Resident and       ║
  24.         '║   Mach 2   Program Package to Speed-Up Basic                        ║
  25.         '║          Both programs are available from Micro-Help, Inc           ║
  26.         '║             Phone No: 404-973-9272 or 1-800-922-3383                ║
  27.         '╚═════════════════════════════════════════════════════════════════════╝
  28.  
  29.         defint a-z
  30.         dim res$(25),oper$(25),format$(5),round(5)
  31.         common shared dtaseg,nor,hi,rev,stack$
  32.  
  33.         scr.buffer$ = space$(4050)                              'reserve memory
  34.         key off: cls: result#= 0: stack$=""
  35.  
  36.         start.col=52: new.col= 1: des=2: ind$="Right": ind2$="Left ": top.row  =23: active= 0
  37.  
  38.         format$(0)="+#,###,###,###,###": round(0)= 0
  39.         format$(1)="+###,###,###,###.#": round(1)= 1
  40.         format$(2)="+##,###,###,###.##": round(2)= 2
  41.         format$(3)="+#,###,###,###.###": round(3)= 3
  42.         format$(4)="+,###,###,###.####": round(4)= 4
  43.  
  44.         call get.monitor (last.monitor,nor,hi,rev,curs.normal,curs.insert,start.line,end.line)
  45.  
  46.         kshift = varptr(scr.buffer$)                            'get segment address
  47.         call hotkey( 3,kscan,kshift,ecode)                      'allocate string space
  48.         dtaseg=kshift
  49.  
  50.         if ecode <> 0 then print "hotkey 3 ";ecode
  51.  
  52.         kscan = 4000
  53.         call hotkey( 4,kscan,kshift,ecode)                      'set storage segment
  54.  
  55.         if ecode <> 0 then print "hotkey 4 ";ecode
  56.  
  57.         call mhmt16(dtaseg,box)                                 'call for space
  58.         call mhwind(stack$, 0,dtaseg, 0, 0, 0, 0, 0, 0, 2,box*16,ecode) 'initialize storage
  59.  
  60.         if ecode <> 0 then print "mhwind ";ecode
  61.  
  62.         '-------------------------- PRINT OPENING SCREEN ----------------------
  63.  
  64.         cls
  65.  
  66.         call mhscr( 0,"╔══════════════════════╗", 1, 1,nor)
  67.         call mhscr( 0,"║ Resident Calculator  ║", 2, 1,nor)
  68.         call mhscr( 0,"║    by Micro-Help     ║", 3, 1, 7)
  69.         call mhscr( 0,"║ and K.J. Laurinolli  ║", 4, 1,nor)
  70.         call mhscr( 0,"║     Version 1.01     ║", 5, 1,nor)
  71.         call mhscr( 0,"║  Activate with Alt X ║", 6, 1,nor)
  72.         call mhscr( 0,"╚══════════════════════╝", 7, 1,nor)
  73.  
  74.         hot.oper= 0
  75.         locate 8,1,1,start.line,end.line                        'cursor location
  76.  
  77.  
  78.         '----------------------- TERMINATE AND STAY RESIDENT ------------------
  79.  
  80. HOT.KEY:
  81.  
  82.         kscan=&h2D: kshift=8: ecode= 0                          '&h2D = Alt X
  83.         call hotkey(hot.oper,kscan,kshift,ecode)                'TSR, HOT-KEY = Alt X
  84.  
  85.         if ecode <> 0 then print "hotkey 0 ";ecode
  86.  
  87.         call get.monitor (monitor,nor,hi,rev,curs.normal,curs.insert,start.line,end.line)
  88.  
  89.         if last.monitor <> monitor then _
  90.            call mhvideo(monitor): last.monitor=monitor          'change monitor
  91.  
  92.         if (kscan=2 and monitor=&hB800) or _
  93.            (kscan=3 and monitor=&hB800) or _
  94.            (kscan=7 and monitor=&hB000) then goto NO.CHANGE
  95.  
  96.         call hotkey( 2, 3,kshift,ecode)                         'change video mode
  97.  
  98.         if ecode <> 0 then print "hotkey 2 ";ecode
  99.  
  100. NO.CHANGE:
  101.  
  102.         call mhwind(stack$, 0,dtaseg, 1, 0, 1, 1,25,80, 1, 0,ecode) 'save whole screen to buffer 1
  103.  
  104.         color 0,7: gosub MESSAGE: goto PRINT.OLD
  105.  
  106.  
  107.         '---------------------------- GET INPUT -------------------------------
  108.  
  109. GET.INPUT:
  110.  
  111.         in.string$="": active= -1
  112.  
  113. CLR.KEY:
  114.  
  115.         while inkey$ <> "": wend                                'clear keyboard buffer
  116.         def seg=0
  117.  
  118. GET.KEY:
  119.  
  120.         n$=inkey$
  121.         poke &h417,(peek(&h417) or &h20)                        'set num lock on
  122.         if n$ = "" then goto GET.KEY                            'get key
  123.  
  124.         def seg
  125.         call mhucase(n$)                                        'upcase input
  126.  
  127.         if (asc(n$) < 58 and _                                  'get numbers
  128.             asc(n$) > 47 or _
  129.             asc(n$) = 46) then goto CLEAR.ENTRY _
  130.                           else goto NO.NUMBER
  131.  
  132. CLEAR.ENTRY:
  133.         call mhscr( 0,space$(29),24,start.col,rev)              'clear entry field
  134.  
  135.         if len(in.string$)=10 then gosub SOUND.OUT: _
  136.             call mhscr( 0,in.string$,24,start.col+28-len(in.string$),rev): _
  137.                goto CLR.KEY
  138.  
  139.         data.in= 1: in.string$=in.string$+n$: _                 'print input
  140.           call mhscr( 0,in.string$+" ",24,start.col+28-(len(in.string$)),rev): _
  141.             goto CLR.KEY
  142.  
  143. NO.NUMBER:
  144.         if (n$="+") or (n$="-") or (n$="*") or (n$="/") _       'get operator
  145.             then _
  146.               if data.in=1 then goto CALC _
  147.             else _
  148.               gosub SOUND.OUT: goto CLR.KEY
  149.  
  150.         if n$="D" then des=des+1: gosub MESSAGE: _              'change decimal
  151.                 if des > 4 then des=0: goto PRINT.NEW _
  152.                                   else goto PRINT.NEW
  153.  
  154.         if n$="T" then _                                        'move tape
  155.             swap start.col,new.col: swap ind$,ind2$: _
  156.                call mhwind(stack$, 0,dtaseg, 2, 0, 1, 1,25,80, 1, 0,ecode): _  'restore screen from buffer 1
  157.                   gosub MESSAGE: goto PRINT.OLD
  158.  
  159.         if n$="Q" then if len(in.string$) > 0 then _            'clear entry field
  160.            call mhscr( 0,space$(29),24,start.col,rev): _
  161.                goto GET.INPUT
  162.  
  163.         if n$="Z" then in.string$="0": goto SET.LENGTH          'clear result
  164.  
  165.         '--- remove REM from the next 3 lines to make X to release memory
  166.  
  167. REM     if n$="X" then hot.oper= 9: _                           'release memory if X entered
  168. REM        def seg=0: poke &h417,(peek(&h417) and &hDF): def seg: _
  169. REM           goto HOT.KEY
  170.  
  171.         if n$=chr$(27) then  _                                  'exit
  172.          def seg=0: poke &h417,(peek(&h417) and &hDF): def seg: _
  173.              call mhwind(stack$, 0,dtaseg, 2, 0, 1, 1,25,80, 1, 0,ecode): _                             'restore whole screen from buffer 1
  174.                   goto HOT.KEY                                  'hide again
  175.  
  176.         if n$="H" then call HELP: goto CLR.KEY                  'call help
  177.  
  178.         if n$=chr$(8) then _                                    'backspace
  179.            if len(in.string$) > 0 then gosub BACKSPACE: goto CLR.KEY else gosub SOUND.OUT: goto CLR.KEY
  180.  
  181.         gosub SOUND.OUT: goto CLR.KEY
  182.  
  183.  
  184.         '*************************** BACKSPACE ********************************
  185.  
  186. BACKSPACE:
  187.  
  188.         in.string$=left$(in.string$,len(in.string$)-1): res$(24)=in.string$
  189.         call mhscr( 0,space$(29),24,start.col,rev)              'clear entry field
  190.         call mhscr( 0,in.string$,24,start.col+28-len(in.string$),rev)
  191.         return
  192.  
  193.  
  194.         '****************************** CALC **********************************
  195. CALC:
  196.  
  197.         data.in=0
  198.         if val(in.string$)=0 and n$="/" then gosub SOUND.OUT:      goto CALC.DONE
  199.         if n$="+" then result#=result#+val(in.string$): goto CALC.DONE
  200.         if n$="-" then result#=result#-val(in.string$): goto CALC.DONE
  201.         if n$="*" then result#=result#*val(in.string$): goto CALC.DONE
  202.         if n$="/" then result#=result#/val(in.string$): goto CALC.DONE
  203.  
  204. CALC.DONE:
  205.  
  206.         un.round$=in.string$                                    'round input
  207.         gosub ROUND.INPUT
  208.  
  209. SET.LENGTH:
  210.  
  211.         if des > 0 then number$=left$(number$,instr(number$,chr$(0))-1) 'strip trailing chr$(0)
  212.  
  213.         if n$<>"Z" then res$(24)=number$+"  "+n$+"= " else _    'store last input+operator
  214.                         res$(24)=number$+"  CL ": result#=0
  215.  
  216.         if len(res$(24)) < 20 then res$(24)=space$(20-len(res$(24)))+res$(24)
  217.  
  218.         for row=1 to 23                                         'move all up 1 line
  219.           res$(row)=res$(row+1)
  220.         next
  221.  
  222. PRINT.OLD:
  223.  
  224.         for row=23 to 1 step -1                                 'print old results + operator
  225.            if res$(row) = "" then row=1: goto OLD.DONE
  226.            top.row=row
  227.            call mhscr( 0,space$( 9)+res$(row),row,start.col,rev)
  228. OLD.DONE:
  229.         next
  230.  
  231. PRINT.NEW:                                                      'print result
  232.  
  233.         call mhscr( 0,space$(29),24,start.col,rev)              'clear entry field
  234.         un.round$=str$(result#)
  235.         gosub ROUND.INPUT
  236.         call mhpusing(stack$, 0,24,start.col+6,rev,32,ecode,number$,format$(des))
  237.         if ecode<>0 then locate 5,1: print "Ecode=";ecode
  238.  
  239.         goto GET.INPUT
  240.  
  241.  
  242.         '************************** ROUND INPUT *******************************
  243.  
  244. ROUND.INPUT:
  245.  
  246.         if des > 0 then _
  247.            number$=space$(20): lset number$=" "+un.round$+chr$(0): _
  248.               call mhround(stack$,number$,round(des)) _
  249.                    else _
  250.               number$=" "+str$(fix(val(un.round$)+.5))
  251.  
  252.         return  'round.input
  253.  
  254.         '*************************** MESSAGE **********************************
  255.  
  256. MESSAGE:
  257.  
  258.         if not active then _
  259.            call mhscr( 0,space$(20)+"0.00"+space$(5),24,start.col,rev)   'print first 0
  260.  
  261.         call mhscr( 0," « Tape= "+ind$+" »  « Dec="+str$(round(des))+" » ",25,start.col,rev)        'message
  262.  
  263.         return  'message
  264.  
  265.         '**************************** SOUND ***********************************
  266.  
  267. SOUND.OUT:
  268.  
  269.         out &h43,182: out &h42,&h33: out &h42,5                 ' sound effects by Micro-Help
  270.         n=inp(&h61): n1=n: n=n or 3: out &h61,n
  271.         for a!=1 to 500: next
  272.  
  273.         out &h42,&h33: out &h42,6
  274.         for a!=1 to 500: next
  275.  
  276.         out &h61,n1
  277.         return          'sound.out
  278.  
  279.  
  280.         '************************ GET MONITOR TYPE ****************************
  281.  
  282.         defint a-z
  283.  
  284. SUB GET.MONITOR(MONITOR,NOR,HI,REV,CURS.NORMAL,CURS.INSERT,START.LINE,END.LINE) STATIC
  285.  
  286.         def seg=0
  287.  
  288.         if (peek(&h410) and &h30)=&h30 then _
  289.            nor= 7: hi=15: rev=112: curs.normal=3085: curs.insert=1293: _
  290.            start.line=12: end.line=13: _
  291.            monitor=&hB000: _                    '&hB000 for mono
  292.            color nor,0,0 _
  293.         else _
  294.            nor=30: hi=31: rev= 79: curs.normal=1543: curs.insert=1031: _
  295.            start.line= 6: end.line= 7: _
  296.            monitor=&hB800: _                    '&hB800 for color &hFFFF for no snow-check
  297.            color 7,0,0
  298.  
  299.         def seg
  300.  
  301.         call mhvideo(monitor)
  302.  
  303. end sub         'get.monitor mono / color
  304.  
  305.         '******************************* HELP *********************************
  306.  
  307. SUB HELP STATIC
  308.  
  309.         call mhwind(stack$,hi,dtaseg, 1, 0, 3,20,19,63, 2, 2,ecode)   'save window to buffer 3
  310.  
  311.         if ecode <> 0 then print " Help Error 1 ="; ecode
  312.  
  313.         for x= 4 to 18                                                  'clear window
  314.            call mhscr( 0,space$(42), x,21,nor)
  315.         next
  316.  
  317.         call mhscr( 0,"   TSR Calculator by K. Laurinolli",      4,22,hi)
  318.         call mhscr( 0,"            404-981-9550",                5,22,hi)
  319.         call mhscr( 0,"             VALID KEYS:",                6,22,hi)
  320.  
  321.         call mhscr( 0,"0 - 9 Use Only Cursor Pad Keys",          8,22,hi)
  322.         call mhscr( 0,"+, -, * and /  to Calculate",             9,22,hi)
  323.         call mhscr( 0,"H     Help",                             10,22,hi)
  324.         call mhscr( 0,"Z     Zero Result",                      11,22,hi)
  325.         call mhscr( 0,"D     Move Decimal Point",               12,22,hi)
  326.         call mhscr( 0,"Q     Clear Entry",                      13,22,hi)
  327.         call mhscr( 0,"T     Move Tape between Left and Right", 14,22,hi)
  328.         call mhscr( 0,"──   Delete Last Character of Entry",   15,22,hi)
  329.         call mhscr( 0,"<Esc> Return to Previous Application",   16,22,hi)
  330.  
  331.         call mhscr( 0,"      Press Any key to Continue",        18,22,hi)
  332.  
  333. AGAIN:  b$=inkey$: if b$="" then goto AGAIN
  334.  
  335.         while inkey$ <> "": wend                                'clear keyboard buffer
  336.         call mhwind(stack$, 0,dtaseg, 2, 0, 3,20,19,63, 2, 0,ecode)   'restore help window from buffer 3
  337.  
  338.         if ecode <> 0 then print " Help Error 2 ="; ecode
  339.  
  340. end sub         'help
  341.  
  342.         ''' 3      ╔══════════════════════════════════════════╗
  343.         ''' 4      ║    TSR Calculator by K. Laurinolli       ║
  344.         ''' 5      ║             404-981-9550                 ║
  345.         ''' 6      ║              VALID KEYS:                 ║
  346.         ''' 7      ║                                          ║
  347.         ''' 8      ║ Cursor Pad Keys   0 - 9                  ║
  348.         ''' 9      ║ +, -, * and /  to Calculate              ║
  349.         ''' 10     ║ H     Help                               ║
  350.         ''' 11     ║ Z     Zero Result                        ║
  351.         ''' 12     ║ D     Change Decimal Point               ║
  352.         ''' 13     ║ Q     Clear Entry                        ║
  353.         ''' 14     ║ T     to move Tape between Left and Right║
  354.         ''' 15     ║ ──   Delete Last Character of Entry     ║
  355.         ''' 16     ║ <Esc> Return to Previous Application     ║
  356.         ''' 17     ║                                          ║
  357.         ''' 18     ║       Press Any key to Continue          ║
  358.         ''' 19     ╚══════════════════════════════════════════╝
  359.  
  360.